home *** CD-ROM | disk | FTP | other *** search
/ Atari Mega Archive 1 / Atari Mega Archive - Volume 1.iso / language / gfaxpert.lzh / START / GFASTART.GFA (.txt) next >
GFA-BASIC Atari  |  1986-10-19  |  10KB  |  496 lines
  1. ' ********************
  2. ' *** GFASTART.GFA ***    compile as *** GFASTART.PRG ***
  3. ' ********************
  4. ' *** this program runs in all resolutions
  5. ' *** 'Shell'-program for running compiled GFA-programs
  6. ' *** put GFASTART.PRG in the main directory
  7. ' *** programs should exit with CHAIN "\GFASTART.PRG"
  8. ' *** © Han Kempen (22-1-'90)
  9. '
  10. DEFWRD "a-z"
  11. '
  12. start$="\GFASTART.INF"          ! last path saved here
  13. '
  14. CLS
  15. ' @check.boot                   ! check for boot-virus (not activated)
  16. '
  17. drive$=CHR$(65+GEMDOS(25))      ! current drive
  18. '
  19. bytes%=DFREE(0)                 ! slow on harddisk (unless FATSPEED installed)
  20. current$=drive$+": "+STR$(bytes%)+" bytes free"
  21. '
  22. IF EXIST(start$)
  23.   OPEN "I",#1,start$            ! last accessed folder in GFASTART.INF
  24.   INPUT #1,path$
  25.   CLOSE #1
  26. ELSE
  27.   path$=drive$+":\"             ! main directory
  28. ENDIF
  29. '
  30. SELECT XBIOS(4)                 ! examine resolution
  31. CASE 2
  32.   high.res!=TRUE
  33.   scrn.col.max&=80
  34.   fac&=1
  35. CASE 1
  36.   med.res!=TRUE
  37.   scrn.col.max&=80
  38.   fac&=2
  39. CASE 0
  40.   low.res!=TRUE
  41.   scrn.col.max&=40
  42. ENDSELECT
  43. '
  44. IF high.res!
  45.   VSETCOLOR 1,0
  46. ELSE IF med.res!
  47.   @standard.med.colors
  48. ELSE
  49.   @standard.low.colors
  50. ENDIF
  51. '
  52. IF PEEK(&H444)<>0               ! not perfect
  53.   IF low.res! OR med.res!
  54.     SPOKE &HFF820A,252          ! NOT if you use a TV through a modulator !!
  55.     PRINT
  56.     PRINT " Vertical frequency now 60 Hz"
  57.   ENDIF
  58.   '
  59.   SPOKE &H444,0
  60.   PRINT
  61.   PRINT " Write Verify Test switched off"
  62.   '
  63.   IF VAL(RIGHT$(DATE$,2))<88            ! not perfect either
  64.     HIDEM
  65.     IF med.res! OR high.res!
  66.       LOCATE 1,9
  67.       PRINT @center$("START-SHELL")
  68.       DEFLINE 1,5
  69.       RBOX 22*8,10*16/fac&,58*8,15*16/fac&
  70.       LOCATE 25,12
  71.       @start.date.input
  72.       LOCATE 25,14
  73.       @start.time.input
  74.       DEFLINE 1,1
  75.     ELSE
  76.       LOCATE 1,9
  77.       PRINT @center$("STARTLOW-SHELL")
  78.       DEFLINE 1,3
  79.       RBOX 2*8,10*8,38*8,15*8
  80.       LOCATE 4,12
  81.       @start.date.input
  82.       LOCATE 4,14
  83.       @start.time.input
  84.       DEFLINE 1,1
  85.     ENDIF
  86.     SHOWM
  87.   ENDIF
  88. ENDIF
  89. '
  90. IF high.res! OR med.res!
  91.   SELECT DPEEK(&H4A6)           ! first check if two drives connected
  92.   CASE 1
  93.     drive$="A "
  94.   CASE 2
  95.     drive$="A B "
  96.   ENDSELECT
  97.   FOR n&=2 TO 15                 ! now check other drives
  98.     IF BTST(BIOS(10),n&)
  99.       drive$=drive$+CHR$(n&+65)+" "
  100.     ENDIF
  101.   NEXT n&
  102.   bottom$="drives: "+drive$+"     "+current$
  103. ELSE
  104.   bottom$=current$
  105. ENDIF
  106. '
  107. CLS
  108. LOCATE 1,25
  109. PRINT @center$(bottom$)
  110. '
  111. m$="Choose program      <Cancel> = Quit"
  112. REPEAT
  113.   @fileselect(path$+"*.PRG","",m$,file$)
  114. UNTIL file$="" OR RIGHT$(file$)="\" OR RIGHT$(file$,4)=".PRG"
  115. '
  116. CLS
  117. IF file$="" OR RIGHT$(file$)="\"
  118.   ' *** user wants to quit
  119.   IF EXIST(start$)
  120.     KILL start$         ! kill GFASTART.INF
  121.   ENDIF
  122.   SYSTEM
  123. ELSE
  124.   ' *** user chose *.PRG-file
  125.   @parse.filename(file$,d$,p$,f$,e$)
  126.   path$=d$+":"+p$
  127.   OPEN "O",#1,start$
  128.   PRINT #1,path$        ! remember last path
  129.   CLOSE #1
  130.   CHAIN file$           ! start the program
  131. ENDIF
  132. '
  133. ' ------------------------------------------------------------------------------
  134. '
  135. DEFFN center$(text$)=SPACE$((scrn.col.max&-LEN(text$))/2)+text$
  136. '
  137. > PROCEDURE check.boot
  138.   ' *** compute checksum of bootsector and warn user if bootsector executable
  139.   LOCAL drive&,buffer$,buffer%,sum%,n&,m$
  140.   PRINT " Checking boot-sector ..."
  141.   drive&=GEMDOS(&H19)
  142.   buffer$=SPACE$(512)
  143.   buffer%=VARPTR(buffer$)
  144.   ~BIOS(4,0,L:buffer%,1,0,drive&)    ! bootsector (0) of current drive in buffer
  145.   sum%=0
  146.   FOR n&=0 TO 255
  147.     ADD sum%,CARD{buffer%+n&*2}
  148.   NEXT n&
  149.   sum%=sum% AND &HFFFF
  150.   IF sum%=&H1234
  151.     m$="Bootsector|executable :|this could be|a boot-virus"
  152.     ALERT 3,m$,2," OK |STOP",k&
  153.   ENDIF
  154. RETURN
  155. ' **********
  156. '
  157. > PROCEDURE get.path(VAR default.path$)
  158.   ' *** return default path (current drive and folder)
  159.   ' *** e.g. A:\GAMES\
  160.   LOCAL default.drive&,default.drive$,buffer$,buffer%
  161.   CLR default.path$
  162.   default.drive&=GEMDOS(&H19)
  163.   default.drive$=CHR$(default.drive&+65)
  164.   buffer$=SPACE$(64)
  165.   buffer%=VARPTR(buffer$)
  166.   VOID GEMDOS(&H47,L:buffer%,0)
  167.   default.path$=CHAR{buffer%}
  168.   IF default.path$<>""
  169.     default.path$=default.drive$+":"+default.path$+"\"
  170.   ELSE
  171.     default.path$=default.drive$+":\"
  172.   ENDIF
  173. RETURN
  174. ' **********
  175. '
  176. > PROCEDURE standard.med.colors
  177.   ' *** standard-colors for Medium resolution
  178.   LOCAL n&,col$,r&,g&,b&
  179.   RESTORE col.med.data
  180.   FOR n&=0 TO 3
  181.     READ col$
  182.     r&=VAL(LEFT$(col$))
  183.     g&=VAL(MID$(col$,2,1))
  184.     b&=VAL(RIGHT$(col$))
  185.     VSETCOLOR n&,r&,g&,b&
  186.   NEXT n&
  187.   '
  188. col.med.data:
  189.   DATA 777,000,700,060
  190. RETURN
  191. ' **********
  192. '
  193. > PROCEDURE standard.low.colors
  194.   ' *** standard-colors for Low resolution
  195.   LOCAL n&,col$,r&,g&,b&
  196.   RESTORE col.low.data
  197.   FOR n&=0 TO 15
  198.     READ col$
  199.     r&=VAL(LEFT$(col$))
  200.     g&=VAL(MID$(col$,2,1))
  201.     b&=VAL(RIGHT$(col$))
  202.     VSETCOLOR n&,r&,g&,b&
  203.   NEXT n&
  204.   '
  205. col.low.data:
  206.   DATA 777,000,700,060,007,005,520,050,555,111,077,053,707,505,550,770
  207. RETURN
  208. ' **********
  209. '
  210. > PROCEDURE start.date.input
  211.   ' *** input of date
  212.   ' *** accepts different formats (day-month-year), e.g. :
  213.   ' *** 1-6-'88   02-11-88   3.6.88   2/1/88   12 June 1988   9 Aug 88
  214.   LOCAL x&,y&,date.input$,ok!,day$,day&,month.input$,month$,n&,month!,month&,year$,year&
  215.   LOCAL new.date$
  216.   PRINT " Date (dd.mm.yy)   : ";
  217.   x&=CRSCOL
  218.   y&=CRSLIN
  219.   ON ERROR GOSUB start.date.input.error
  220.   '
  221. start.date.input:
  222.   ' *** input of date
  223.   ok!=TRUE
  224.   FORM INPUT 18,date.input$
  225.   ' *** day
  226.   day.len&=VAL?(date.input$)
  227.   IF day.len&>2
  228.     IF INSTR(date.input$,".")=2
  229.       day.len&=1
  230.     ELSE
  231.       IF INSTR(date.input$,".")=3
  232.         day.len&=2
  233.       ELSE
  234.         ok!=FALSE
  235.       ENDIF
  236.     ENDIF
  237.   ENDIF
  238.   day$=LEFT$(date.input$,day.len&)
  239.   day&=VAL(day$)
  240.   IF day&>31 OR day&<1
  241.     ok!=FALSE
  242.   ENDIF
  243.   ' *** mmonth
  244.   month.input$=RIGHT$(date.input$,LEN(date.input$)-(day.len&+1))
  245.   month.len&=VAL?(month.input$)
  246.   IF month.len&=0
  247.     month$=LEFT$(month.input$,3)
  248.     month$=UPPER$(month$)
  249.   start.month.data:
  250.     DATA JAN,1,FEB,2,MAR,3,APR,4,MAY,5,JUN,6,JUL,7
  251.     DATA AUG,8,SEP,9,OCT,10,NOV,11,DEC,12
  252.     DIM date.input.month$(12),date.input.month&(12)
  253.     RESTORE start.month.data
  254.     FOR n&=1 TO 12
  255.       READ date.input.month$(n&),date.input.month&(n&)
  256.     NEXT n&
  257.     FOR n&=1 TO 12
  258.       IF date.input.month$(n&)=month$
  259.         month!=TRUE
  260.         month&=date.input.month&(n&)
  261.       ENDIF
  262.     NEXT n&
  263.     ERASE date.input.month$()
  264.     ERASE date.input.month&()
  265.     IF NOT month!
  266.       ok!=FALSE
  267.     ENDIF
  268.   ELSE
  269.     month&=VAL(month.input$)
  270.   ENDIF
  271.   IF month&>12 OR month&<1
  272.     ok!=FALSE
  273.   ENDIF
  274.   month$=STR$(month&)
  275.   IF (month&=4 OR month&=6 OR month&=9 OR month&=11) AND day&>30
  276.     ok!=FALSE
  277.   ENDIF
  278.   IF (month&=1 OR month&=3 OR month&=5 OR month&=7 OR month&=8 OR month&=10 OR month&=12) AND day&>31
  279.     ok!=FALSE
  280.   ENDIF
  281.   ' *** year
  282.   year$=RIGHT$(date.input$,2)
  283.   IF VAL?(year$)<>2 OR INSTR(year$,".") OR VAL(year$)<88
  284.     ok!=FALSE
  285.   ENDIF
  286.   year&=VAL(year$)
  287.   IF month&=2
  288.     IF day&>28
  289.       IF (year& MOD 400=0) AND day&<>29
  290.         ok!=FALSE
  291.       ELSE
  292.         IF year& MOD 100=0 AND (year& MOD 400<>0)
  293.           ok!=FALSE
  294.         ELSE
  295.           IF (year& MOD 4=0) AND day&<>29
  296.             ok!=FALSE
  297.           ELSE
  298.             IF (year& MOD 4<>0)
  299.               ok!=FALSE
  300.             ENDIF
  301.           ENDIF
  302.         ENDIF
  303.       ENDIF
  304.     ENDIF
  305.   ENDIF
  306.   ' *** print date
  307.   IF NOT ok!
  308.     PRINT CHR$(7);
  309.     PRINT AT(x&,y&);STRING$(LEN(date.input$)," ");
  310.     PRINT AT(x&,y&);"WRONG FORMAT !!";
  311.     PAUSE 50
  312.     PRINT AT(x&,y&);STRING$(18," ");
  313.     PRINT AT(x&,y&);"";
  314.     GOTO start.date.input
  315.   ENDIF
  316.   LET new.date$=day$+"."+month$+"."+year$
  317.   SETTIME TIME$,new.date$
  318.   ON ERROR
  319. RETURN
  320. ' ***
  321. > PROCEDURE start.date.input.error
  322.   ' *** unexpected error
  323.   ok!=FALSE
  324.   ON ERROR GOSUB start.date.input.error
  325.   RESUME NEXT
  326. RETURN
  327. ' **********
  328. '
  329. > PROCEDURE start.time.input
  330.   ' *** input of time (seconds optional)
  331.   ' *** <Return> = 00:00:00
  332.   ' *** accepts different f